\ Install - Mops version.
\ July 90		Save nucleus implemented.
\ Sept 90		Necessary mod for our new "startup" CODE resource.
\ Oct 91		Changed to view/window+.
\ May 92		Changed vscroll objects according to "new way" for controls.

need	window+

konst resLocked		constant	LOCKED
konst resPurgeable	constant	PURGEABLE

    0	value		CURSTACK
    0	value		CURDICT

    0	value		HEAPAVAIL
false	value		GOTFREE?
true	value		SAVE?

    0	value		QUITWORD
    0	value		ABORTWORD

	string+		$TMP

	int		APREFNUM
	var		APPARAM

    21	dialog		IDLG

: NOGO	3 beep  3 beep  close: iDlg  set: fWind
	cr ." Res error# " .
	cr ." Type any key to return to Finder, hopefully"
	key  bye  ;

: CHK	word0  call reserror  i->l  ?dup
	IF  nogo  THEN  ;

' null	vect	TEMP

: ONERROR		\ ( errCfa -- )
		\ Here we temporarily set the error vectors.  This is normally
		\ illegal since we're in a module and the vectors are not.  But
		\ we're safe here, so we kludge it.
	-> temp		\ Store to an internal vect, convert to reloc
	['] temp @  dup  ['] abortvec !  ['] dflt-die !  ;

\ Class RES+ adds methods to Resource to allow various modifications
\ to resources.  We'll put more in as we need them.

:class	RES+	super{ resource }

objPtr	TEMPRES  class_is  res+

:m CHANGED:	get: self  call ChangedResource  ;m

:m ADDRES:  { s255 -- }
	get: self
	get: type  get: ID  makeint
	s255  call AddResource  chk  ;m

:m CHANGETO:	\ ( res -- )
	-> tempRes
	get: tempRes  dup  call DetachResource  put: self  ;m

:m SETATTRS:	\ ( n -- )
	get: self  swap  makeint  call SetResAttrs  chk
	changed: self  ;m

;class

	res+	SRCRES
	res+	DSTRES

: COPYRES		\ ( type resID -- )  Copies the resource by copying
		\  the handle's data in memory.  Use this one for resources
		\  currently in use.
	2dup  set: srcRes  set: dstRes
	getnew: srcRes  chk  srcRes ->: dstRes
	nullOSstr  addRes: dstRes  chk  ;

: CHANGERES	\ ( type resID -- )  Copies the resource by detaching its
		\  handle and attaching it to the new resource.  Use this
		\  one for resources not in use - it has less overhead.
	2dup  set: srcRes  set: dstRes
	getnew: srcRes  chk  srcRes changeTo: dstRes
	nullOSstr  addRes: dstRes  chk  ;

: !STACK	curStack -> stkSpace  ;

: @HEAP		\ Returns starting heap size for this nucleus.
	gotFree?  NIF  free  -> heapAvail  true -> gotFree?  THEN
	heapAvail  ;

: CURHEAP		\ Computes amount of heap available for current configuration.
	@heap  stkspace curStack - +  room curDict - +  ;

: SETMEM		\ Sets nucleus stack to selected values
	!stack
	curDict -> maxdic  ;

: iMsg		\ ( addr1 len1 addr2 len2 -- )  Gives informatory message
	"  " "  " ParamText draw: iDlg  ;

: ChR		\ ( handle -- handle )  Marks the resource for update to disk
	dup call ChangedResource  ;

objPtr	theMod  class_is  module
handle	ModHdl

: (ADDMOD)  { theCfa n \ ID -- }
	theCfa mod?  NIF  drop  EXIT  THEN
	>obj -> theMod
	install?: theMod  0EXIT	\ Out if not to install this mod
	" module:"  theCfa >name n>count  iMsg

		binName: theMod  name: fFcb  0 setVref: fFcb
		openReadOnly: fFcb  ?error 138
		size: fFcb  dup  new: modHdl
		lock: modHdl			\ Maybe we need this
		ptr: modHdl  swap  read: fFcb
		unlock: modHdl		\ Unlock before error check
		close: fFcb  drop  ?error 141

\	release: theMod   load: theMod
	word0 'type CODE  call UniqueID  i->l  -> ID
	'type CODE  ID  set: dstRes  ID  setResID: theMod
	( handle: theMod )  get: modHdl  put: dstRes
	theCfa >name n>count str255  addRes: dstRes
			\ NOTE: we don't release modHdl since it's the
			\ Resource Manager's baby now.
	locked purgeable or  setAttrs: dstRes  ;

: ADDMODS
	"  " 2dup 2dup 2dup  paramText
	" Installing ^0 ^1" 21 putText: iDlg
	['] (addmod)  0  trav  ;

: INVWORD		\ ( item# -- )
	40 beep 0 $ ffff rot  setSelect: iDlg  ReturnToModal  ;

:a OK		\ Validates quits & abort words; if bad returns to modal
	10 getText: iDlg  sFind  NIF  10 invWord  EXIT  THEN
	-> quitword
	11 getText: iDlg  sFind  NIF  11 invWord  EXIT  THEN
	-> abortword
	true  ;a

:a CANCEL	false  ;a

cfas{	ok cancel null null null null null null null null null
	togitem togItem togItem null null null null null null null }
111  init: iDlg   1  setBold: iDlg

: GETR
	get_appl_name ->: $tmp  all: $tmp  5  putText: iDlg
	get_appl_vers ->: $tmp  all: $tmp  4  putText: iDlg
	get_appl_sig  pad !  pad 4  3  putText: iDlg  ;

: DROP@		\ ( addr len -- addr' )
		\ Fetches 1st four bytes on an odd byte, pad with blanks
	>r sp@ $ 20202020 rot rot r> 4 min cmove  ;

: SETFREF		\ ( type n -- )
	'type FREF  swap  set: srcRes  getNew: srcRes
	get: srcRes  ChR  >ptr !  ;


:class	SETUPHDR	super{ object }
		\ A dummy class to map the info area at the start of the
		\  Setup segment
	var		dummy
	int		&bra		\ The names are the same, with & in front
	var		&maxDic
	var		&minHeap
	var		&dicSize
	var		&StkSpace
	var		&RstkSpace
	bool	&installed
	byte	spare
	int		&nop

:m SETUP:  { instld? -- }

\	$ a9ff  	put: &nop			\ Include to breakpoint on run

	maxDic		put: &maxDic
	minHeap		put: &minHeap
	stkSpace	put: &stkSpace
	RstkSpace	put: &RstkSpace
	instld?		put: &installed  ;m
;class

: SETDIC&HEAP		\ ( instld? -- )
	ptr: dstRes  setup: setupHdr  ; 	\ Forced bind to pseudo-object

: SETAPPLSIZE
	here  nptr: srcRes  -		\ Offset to Here
	curDict +  setSize: dstRes  ;

: UNPATCH  { \ ^br -- }
	brs -> ^br
	^br @	['] *  6 +	!	4 ++> ^br		\ ***NOTE: add the 6 for words
	^br @	['] /  6 +	!	4 ++> ^br		\ with "xinfo" optimization info
	^br @	['] mod	!	4 ++> ^br
	^br @	['] /mod	!	4 ++> ^br
	^br @	['] u/mod	!	4 ++> ^br
	^br @	['] mulx	!  ;

: ADDCODE		\ Adds the CODE resources to a new application.

	" dictionary" "  "  iMsg

	'type CODE  0  copyRes			\ Copy CODE 0 (Jump table)
	  locked  setAttrs: dstRes
	'type CODE  1  changeRes		\ And CODE 1 (Setup)
	  purgeable  setAttrs: dstRes
	true  setDic&heap
\ Now we set all the various flags and vectors appropriately:
	unpatch
	false -> initzed?  true -> instld?
	false -> MRopen?  false -> use_paths?
	0 -> CPaddr
	classinit: fWind  clear: fFcb
	0 -> actW  ['] appInit -> objinit
	quitword -> quitvec
	abortword dup -> abortvec  dup -> dflt-die  -> setFwind
			\ Catch all the possibilities!
			\ Note: we still have to PURGE modules in the dictionary.
			\ We leave this to the last moment as some are still in use.
	'type CODE  2  ChangeRes		\ Copy CODE 2 (main dictionary)
	locked purgeable or  setAttrs: dstRes
	setApplSize  ;

: SAVECODE  { \ addr len -- }	\ Copies the CODE resources for
								\  a Saved nuc.
	'type CODE  0  copyRes		\ Copy CODE 0 (Jump table)
	  locked  setAttrs: dstRes
	'type CODE  3  changeRes		\ And CODE 3 (Handlers)
	  purgeable  setAttrs: dstRes
	'type CODE  1  changeRes		\ And CODE 1 (Setup)
	  purgeable  setAttrs: dstRes
	false  setDic&heap
\ Last but not least, we'll copy CODE 2 (the main dictionary).
\ First we set all the various flags and vectors appropriately:
	unpatch
	false -> initzed?  0 -> ExBoffs  +curs
	false -> MRopen?  true -> use_paths?
	0 -> CPaddr
	classinit: fWind  true -> fWind?  clear: fFcb
	0 -> uFind  0 -> key  0 -> key!
	0 -> pause  0 -> getSpace
	0 -> rngErr 0 -> $err
	0 -> objinit	0 -> extra_inits
	0 -> abortvec	0 -> setfWind	0 -> dflt-die
	0 -> modload	0 -> TEidle	0 -> compinline
	0 -> actW
\ Whew!  And to think, I found most of those by trial and error!!

	'type CODE  2  ChangeRes	\ Yes, I know it's in use, but it's
					\  OK as we're going to quit
					\  straight away!

	purgeable  setAttrs: dstRes	\ Note: we don't set it locked since
					\  the Setup segment will resize it
					\  before moving it high, locking and
					\  calling it.
	['] echo? >link (forget)
	here  nptr: srcRes  -		\ Offset to Here
	setSize: dstRes  ;

scon	$ALQ	"alert%"	& %  & "  instead

: NEW_APPLICATION  { \ sig addr len -- }
		\ This word does all the hard work of creating the
		\ installed application file.
	['] nogo  onError
	5 getText: iDlg  -> len -> addr
	addr len  name: fFcb
	delete: fFcb  drop			\ Delete any duplicate file
	addr len str255
	call CreateResFile  chk		\ Create new res file for applicn
	0  buf255  call OpenResFile  drop  chk
	3  getText: iDlg  drop@ -> sig	\ New sig
	'type APPL  sig  set: fFcb		\ Set type & sig of appl
	$ 21  fFcb $ 28 + c!			\ Set Bundle bit
	setFileInfo: fFcb
	addMods					\ Copy chosen modules
	addCode					\ and CODE 0, 1 and 2
	['] nogo  onError
	13 getitem: iDlg
	if	true -> fWind?			\ fWind? wanted - copy it (WIND 256)
		'type WIND  256  copyRes
		12 getitem: iDlg  8 <<  ptr: dstRes 10 + w!
						\ Mark visible or not
	else	false -> fWind?
	then
	'type SIZE  -1   copyRes		\ Copy SIZE -1
	'type BNDL  128  copyRes		\ and don't drop our BNDL (128)
	sig  ptr: dstRes  !			\ Store in new BNDL
\ Now set up FREFs:
	'type FREF  128  copyRes		\ FREF for APPL - doesn't change
	10 6 do				\ FREFs 129 onwards
		i getText: iDlg  dup  nif  drop  leave  then
		'type FREF  123 i +  copyRes
		drop@  ptr: dstRes  !
	loop
\ Now we create the new version resource which has a "type" that is the
\ same as the sig, and ID 0.
	sig  0  set: dstRes
	4 getText: iDlg  dup 1+ align  new: dstRes
	str255  ptr: dstRes  over  c@ 1+ cMove
	nullOSstr  addRes: dstRes
\ Now copy the Alert" stuff if we need it
	$alq sfind nip
	if	'type ALRT  900  copyRes
		'type DITL  900  copyRes
	then  ;

: DOINSTALL
	openMR   getnew: iDlg   getR
	" go"	 10 putText: iDlg
	" crash" 11 putText: iDlg
	0 $ ffff 3 setSelect: iDlg
	modal: iDlg
	if	new_application
	then
	close: iDlg
	kludge: instlMod  kludge: pathsmod
	purge			\ Dic image must have no modules loaded
	bye  ;


: SAVENUC  { \ addr len -- }			\ Saves a new Mops nucleus.
	" Mops.new"  -> len -> addr
	addr len  name: fFcb
	create: fFcb  ?error 169
	addr len  str255			\ Create res file for new nuc
	call CreateResFile
	word0  call reserror  i->l  ?error 169
	['] nogo  onError
	0  buf255  call OpenResFile  drop  chk
	'type APPL  'type MOPS  set: fFcb	\ Set type & sig of appl
	$ 21  fFcb $ 28 + c!			\ Set Bundle bit
	setFileInfo: fFcb
	'type WIND  256  copyRes		\ Copy fWind (WIND 256)
	'type BNDL  128  copyRes		\ And don't drop our BNDL (128)
	132 128 do
		'type ICN#  i  copyRes	\ Copy ICN# and icl8 resources
		'type icl8  i  copyRes
	loop
	'type ics8  128  copyRes		\ And we have one ics8 resource too
	132 128 do
		'type FREF  i  copyRes	\ Copy FREFs
	loop

	'type SIZE  -1  copyRes		\ And SIZE -1
	'type ALRT 900  copyRes		\ And ALRT and DITL for alert"
	'type DITL 900  copyRes
\ Now we create the new version resource whose text we get from STR 50.
	'type STR  50  set: srcRes  getNew: srcRes
	ptr: srcRes  size: srcRes  put: $tmp
	'type MOPS  0  set: dstRes
	len: $tmp  dup align  new: dstRes
\	get: $tmp  str255  ptr: dstRes  over  c@ 1+ cMove
	ptr: $tmp  ptr: dstRes  len: $tmp  cmove
	release: $tmp
	nullOSstr  addRes: dstRes
	saveCode			\ Add code resources
	bye  ;				\ That's all, folks


\			=======================

true	value	ICURS

\ scroll bars for Stack and Dictionary headroom

vScroll	VS1		180 15 48  init: vs1
vScroll	VS2		180 85 48  init: vs2

control SAVEBTN
control INSTBTN
control CANBTN
control HEAPBTN

\ We'll do one button the "new way":
radioButton	mxSt		197 14  " ++"   init: mxSt

control miSt  radioID  init: miSt
control mxDi  radioID  init: mxDi
control miDi  radioID  init: miDi

\ Rectangles for formatting screen

rect stRect	20 29 170 49  put: stRect	\ stack headroom
rect hpRect	20 64 170 84  put: hpRect	\ heap start size
rect diRect	20 99 170 119  put: diRect	\ Dictionary headroom
	
rect wRect	100 40 400 210 put: wRect

\ get current limits for stack and dict based on minHeap

: MAXSTACK  curStack curHeap minHeap - +  ;
: MAXDICT   curDict  curHeap minHeap - +  ;

20000	value	MINSTACK
  128	value	MINDICT

: .VAL  { n theRect -- }	\ print number in rect
	theRect ->: tempRect
	4 4 inset: tempRect 100 putTopX: tempRect clear: tempRect
	104 getboty: tempRect 2- gotoxy n 7  .r  ;

: .VS1	curStack stRect .val curHeap hpRect .val  ;
: .VS2	curDict  diRect .val curHeap hpRect .val  ;

:a  DRAWIWIND
	draw: stRect draw: hpRect draw: diRect
	2 tmode 0 tfont 12 tsize
	24 43 gotoxy ." Stack:"
	24 78 gotoxy ." Heap:"
	24 113 gotoxy ." Dictionary:"  .vs1 .vs2   ;a

\ Define the Install utility window

window+		IWIND
view		IVIEW

CFAS{ null null drawIwind null }  actions: iWind

: LISTENER	\ Listens to mouse and drops keys
	begin  key drop  again  ;

\ Create new window, controls

: INSTALL
	vs1  addCtl: iView   vs2  addCtl: iView
	mxSt  addCtl: iView
	wRect "  " dlgWind true false  iView  new: iWind
	2000 32000 putRange: vs1  0 8000 putRange: vs2
	4000 dup put: vs1  put: vs2
	stkspace -> curStack  dicsize -> curDict
	197 46 " --"		iView	new: miSt
	197 84 " ++"		iView	new: mxDi
	197 116 " --"		iView	new: miDi
	238 20 " Save"		iView	new: saveBtn
	236 45 " Install"	iView	new: instBtn
	236 70 " Cancel"	iView	new: canBtn
	150 145 " Max Heap"	iView	new: heapBtn
	-curs   draw: iWind
	begin  key drop  again  ;

: stDn	curStack 8 -  minStack max -> curStack  .vs1  ;
: stUp	curStack 8 +  maxStack min -> curStack  .vs1  ;

: diDn	curDict 32 -  minDict max -> curDict  .vs2  ;
: diUp	curDict 32 +  maxDict min -> curDict  .vs2  ;

CFAS(  stUp stDn null null null  )  actions: vs1
CFAS(  diUp diDn null null null  )  actions: vs2


: CONFIG		close: iWind  setMem  saveNuc  ;
: WINSTALL	close: iWind  setMem  doInstall  ;
: CANCEL		close: iWind  drop: instlmod  icurs -> curs  quit  ;

: DOMXST		curStack 4096 + maxStack min -> curStack .vs1  ;
: DOMIST		curStack 4096 - minStack max -> curStack .vs1  ;
: DOMXDI		curDict 16384 + maxDict min -> curDict .vs2  ;
: DOMIDI		curDict 16384 - minDict max -> curDict .vs2  ;
: DOMXHP		minStack -> curStack .vs1  minDict -> curDict .vs2  ;

' config   actions: saveBtn
' wInstall actions: instBtn
' cancel   actions: canBtn
' doMxSt   actions: mxSt
' doMiSt   actions: miSt
' doMxDi   actions: mxDI
' doMiDi   actions: miDi
' doMxHp   actions: heapBtn

endload					\ ***

\ testing

true  setinstall: testmod
compile: testmod

20000 allot

: go
	10 0 DO  ." hello there!!"  cr  LOOP
	bb  .mods
	500000 0 DO LOOP
	bye  ;

: crash	cr cr ." Oh no!!!"
	500000 0 DO LOOP  bye  ;